home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
EnigmA Amiga Run 1996 February
/
EnigmA AMIGA RUN 04 (1996)(G.R. Edizioni)(IT)[!][issue 1996-02][Skylink CD III].iso
/
earcd
/
midi
/
rustle.lha
/
Rustle
/
Source
/
Rustle.mod
< prev
Wrap
Text File
|
1995-12-02
|
12KB
|
453 lines
(**************************************************************************
:Remark. Format: ein TAB in jeder 3. Spalte: ..tab..tab..tab..
:Program. Rustle
:Contents. plays white noise
:Bugs. "Shit happens." (Murphy)
:Copyright. Freeware---you may copy and use it, but all rights remain
:Copyright. at the author
:Author. Thomas Ansorge
:Address. Dinkelackerring 55, 67435 Neustadt, Deutschland, Europa
:Language. Modula-2
:Translator. M2Amiga V4.3 (deutsch)
:History. 1.0 as of 22-Apr-95: seems to work...
**************************************************************************)
(*$ DEFINE DEBUG := FALSE *)
MODULE Rustle;
FROM Arts IMPORT Assert, BreakPoint, returnVal, Terminate, wbStarted;
FROM Audio IMPORT allocate, allocFailed, audioName, channelStolen, free, IOAudio, IOAudioPtr, lock, noWait, pervol;
FROM DosD IMPORT ctrlC, fail, RDArgsPtr;
FROM DosL IMPORT Delay, FreeArgs, ReadArgs;
FROM ExecD IMPORT IOFlagSet, IORequest, MemReqs, MemReqSet, MsgPort, Message, MessagePtr, MsgPortPtr, Node, write;
FROM ExecL IMPORT AbortIO, AllocMem, CloseDevice, CopyMem, CreateMsgPort, DeleteMsgPort, execVersion, FindTask, FreeMem, GetMsg, OpenDevice, Signal, Wait;
FROM ExecSupport IMPORT BeginIO;
FROM GraphicsD IMPORT DisplayFlags, DisplayFlagSet, GfxBase, GfxBasePtr;
FROM GraphicsL IMPORT graphicsBase;
(*
Es muß nicht \source{Randoms} sein, jeder Zufallszahlengenerator sollte es tun...
*)
FROM Randoms IMPORT Rand0, ReduceToByte;
FROM SYSTEM IMPORT ADDRESS, ADR, CAST, LONGSET, SHIFT, SHORTSET;
FROM Terminal IMPORT WriteLn, WriteString;
(* --------------------------------------------------------------------- *)
CONST
prog_str = "Rustle 1.0/";
date_str = "(22.04.95)";
(*$ IF M68881 OR M68040 *)
ver_str = prog_str + "68020+FPU " + date_str;
(*$ ELSIF M68020 *)
ver_str = prog_str + "68020 " + date_str;
(*$ ELSIF M68010 *)
ver_str = prog_str + "68010 " + date_str;
(*$ ELSE *)
ver_str = prog_str + "68000 " + date_str;
(*$ ENDIF *)
ver_ptr = ADR ("$VER: " + ver_str);
CONST
exec_min_version = 36;
CONST
rustle_buffer_size = 32 * 1024; (* Bytes *)
frequency = 400 * 5000; (* 5000? *)
CONST
template = "VOLUME/N";
TYPE
ChannelArray = ARRAY [0..1] OF SHORTSET;
CONST
left_channels = ChannelArray {SHORTSET {1}, SHORTSET {2}};
right_channels = ChannelArray {SHORTSET {0}, SHORTSET {3}};
TYPE
Status = (doing_nothing, allocating, playing, freeing, quitting);
Location = (back_home, outside);
IOAudioRec = RECORD
io: IOAudio;
status: Status;
location: Location;
END; (* RECORD IOAudioRec *)
IOAudioRecPtr = POINTER TO IOAudioRec;
VAR
(* Pointer *)
data_ptr: ADDRESS;
dummy_msg_ptr: IOAudioRecPtr;
play_port_ptr: MsgPortPtr;
rdargs_ptr: RDArgsPtr;
vol: LONGINT;
vol_ptr: POINTER TO LONGINT;
(* anderes 32bit Zeug *)
ctrlc_sig: LONGSET;
play_sig: LONGSET;
sigs: LONGSET;
(* anderes *)
alloc_key: INTEGER;
left_play_req: IOAudioRec;
right_play_req: IOAudioRec;
VAR (* Flags *)
audio_open := BOOLEAN {FALSE};
quit := BOOLEAN {FALSE};
runtime_error := BOOLEAN {TRUE};
(* --------------------------------------------------------------------- *)
PROCEDURE Err (condition: BOOLEAN; msg: ARRAY OF CHAR); FORWARD;
(* --------------------------------------------------------------------- *)
PROCEDURE AbortChannel (VAR play_rec: IOAudioRec);
BEGIN (* Prozedur AbortChannel *)
IF play_rec.location = outside THEN
AbortIO (ADR (play_rec));
ELSE (* IF play_req.location = outside THEN *)
Err (FALSE, ver_str + ": message not in use!");
END; (* IF play_req.location = outside THEN *)
END AbortChannel; (* Prozedur *)
(* --------------------------------------------------------------------- *)
PROCEDURE AllocChannel (VAR play_req: IOAudioRec; channels: ChannelArray; key: INTEGER);
(* play_req MUSS VAR sein wegen ADR (play_req) weiter unten!!! *)
BEGIN (* Prozedur AllocChannel *)
IF play_req.location = back_home THEN
play_req.io.request.message.node.pri := -100;
play_req.io.request.unit := NIL;
play_req.io.request.command := allocate;
play_req.io.request.flags := noWait;
play_req.io.request.error := 0;
play_req.io.allocKey := key;
play_req.io.data := ADR (channels);
play_req.io.length := SIZE (channels);
play_req.io.period := 0;
play_req.io.volume := 0;
play_req.io.cycles := 0;
play_req.status := allocating;
play_req.location := outside;
BeginIO (ADR (play_req));
ELSE (* IF play_req.location = back_home THEN *)
Err (FALSE, ver_str + ": message already in use!");
END; (* IF play_req.location = back_home THEN *)
END AllocChannel; (* Prozedur *)
(* --------------------------------------------------------------------- *)
(*
Diese Prozedur bricht das Programm sauber und kontextabhängig (Workbench oder
CLI) ab, falls \source{condition = FALSE}. Dabei wird \source{msg} als Fehlertext
ausgegeben.
*)
PROCEDURE Err (condition: BOOLEAN; msg: ARRAY OF CHAR);
BEGIN (* Prozedur Err *)
IF wbStarted THEN
Assert (condition, ADR (msg));
ELSE (* IF wbStarted *)
IF NOT condition THEN
WriteString (msg);
WriteLn;
returnVal := fail;
Terminate ();
END; (* If NOT condition *)
END; (* IF wbStarted *)
END Err; (* Prozedur *)
(* --------------------------------------------------------------------- *)
PROCEDURE HandlePlayMessage (VAR play_req: IOAudioRec; channels: ChannelArray; key: INTEGER);
(* play_req MUSS VAR sein wegen ADR (...) weiter unten!!! *)
(* global: data_ptr *)
(* ------------------------------------------------------------------ *)
PROCEDURE GetAudioConstant (): LONGCARD;
BEGIN (* Funktion GetAudioConstant *)
IF pal IN graphicsBase^.displayFlags THEN
RETURN 3546895;
ELSE (* IF pal IN graphicsBase^.displayFlags *)
RETURN 3579545;
END; (* IF pal IN graphicsBase^.displayFlags THEN ELSE *)
END GetAudioConstant; (* Funktion *)
(* ------------------------------------------------------------------ *)
BEGIN (* Prozedur HandlePlayMessage *)
CASE play_req.status OF
|allocating:
IF play_req.location = back_home THEN
IF play_req.io.request.error = 0 THEN
WITH play_req.io DO
request.command := write;
request.flags := pervol; (* = 12, SHORTSET {3, 2} *)
data := data_ptr;
length := rustle_buffer_size;
period := GetAudioConstant () DIV frequency;
IF vol_ptr # NIL THEN
volume := vol_ptr^;
ELSE (* IF vol_ptr # NIL *)
volume := 4;
END; (* IF vol_ptr # NIL THEN ELSE *)
cycles := 0;
END; (* WITH play_req.io.request *)
play_req.status := playing;
play_req.location := outside;
BeginIO (ADR (play_req));
ELSIF play_req.io.request.error = allocFailed THEN
IF NOT quit THEN
Delay (100);
AllocChannel (play_req, channels, key);
ELSE (* IF NOT quit THEN *)
play_req.status := quitting;
END; (* IF NOT quit THEN *)
ELSE (* IF play_req.io.request.error = 0 *)
Err (FALSE, ver_str + ": allocation failed!");
END; (* IF play_req.io.request.error = 0 *)
ELSE (* IF play_req.location = back_home THEN *)
Err (FALSE, ver_str + ": message already in use!");
END; (* IF play_req.location = back_home THEN *)
|playing:
IF NOT quit THEN
AllocChannel (play_req, channels, key);
ELSE (* IF NOT quit THEN *)
play_req.status := quitting;
END; (* IF NOT quit ELSE *)
END; (* CASE play_req.status OF *)
END HandlePlayMessage; (* Prozedur *)
(* --------------------------------------------------------------------- *)
(*
Für weißes Rauschen brauchen wir einen zufällig gefüllten Bereich CHIP-Speicher.
*)
PROCEDURE InitRustleBuffer (): ADDRESS;
TYPE
RustleBuffer = ARRAY [1..rustle_buffer_size] OF SHORTCARD;
RustleBufferPtr = POINTER TO RustleBuffer;
VAR
buffer_ptr: RustleBufferPtr;
i: [1..rustle_buffer_size];
BEGIN (* Funktion InitRustleBuffer *)
buffer_ptr := AllocMem (rustle_buffer_size, MemReqSet {public, chip});
Err (buffer_ptr # NIL, ver_str + ": no chip memory, no rustle.");
FOR i := 1 TO rustle_buffer_size DO
buffer_ptr^ [i] := ReduceToByte (Rand0 ());
END; (* FOR i := 1 TO rustle_buffer_size *)
RETURN buffer_ptr;
END InitRustleBuffer; (* Funktion *)
(* --------------------------------------------------------------------- *)
(* --------------------------------------------------------------------- *)
BEGIN (* Program Rustle *)
Err (execVersion >= exec_min_version, ver_str + ": Kickstart 2.0 Minimum!");
IF wbStarted THEN
ELSE (* IF wbStarted *)
rdargs_ptr := ReadArgs (ADR (template), ADR (vol_ptr), NIL);
END; (* IF wbStarted ELSE *)
IF vol_ptr # NIL THEN
IF (vol_ptr^ < 0) OR (vol_ptr^ > 64) THEN
WriteString (ver_str + ": 0 <= VOLUME <= 64, using default (4)");
WriteLn;
vol_ptr := NIL;
END; (* IF (vol_ptr^ < 0) OR (vol_ptr^ > 64) THEN *)
END; (* IF vol_ptr # NIL THEN *)
data_ptr := InitRustleBuffer ();
ctrlc_sig := CAST (LONGSET, SHIFT (LONGINT (1), ctrlC));
play_port_ptr := CreateMsgPort ();
Err (play_port_ptr # NIL, ver_str + ": no message port to open Audio.device!");
play_sig := CAST (LONGSET, SHIFT (LONGINT (1), play_port_ptr^.sigBit));
left_play_req.io.request.message.replyPort := play_port_ptr;
OpenDevice (ADR (audioName), 0, ADR (left_play_req.io), LONGSET {});
Err (left_play_req.io.request.error = 0, ver_str + ": Audio.device did not open!");
audio_open := TRUE;
CopyMem (ADR (left_play_req), ADR (right_play_req), SIZE (left_play_req));
alloc_key := left_play_req.io.allocKey;
left_play_req.location := back_home;
right_play_req.location := back_home;
REPEAT
IF left_play_req.status = doing_nothing THEN
AllocChannel (left_play_req, left_channels, alloc_key);
END; (* IF left_play_req.status = doing_nothing *)
(*
Solange wir keinen \source{allocKey} vom Audio-Device haben, dürfen wir nur
den einen Kanal alloziieren und müssen warten, bis wir ihn haben.
*)
IF alloc_key # 0 THEN
IF right_play_req.status = doing_nothing THEN
AllocChannel (right_play_req, right_channels, alloc_key);
END; (* IF right_play_req.status = doing_nothing *)
END; (* IF alloc_key # 0 *)
sigs := Wait (ctrlc_sig + play_sig);
(*
Ein Play-Request kam zurück. Normalerweise passiert das hier nur in den
folgenden Fällen:\begin{itemize}
\item Ein Kanal wurde gerade (hoffentlich) erfolgreich alloziiert.
\item Ein Kanal wurde uns genommen.
\item Ein Kanal wurde mit \source{AbortIO ()} abgebrochen.
\end{itemize}
*)
IF play_sig <= sigs THEN
dummy_msg_ptr := GetMsg (play_port_ptr);
IF dummy_msg_ptr # NIL THEN
Signal (FindTask (NIL), play_sig);
IF alloc_key = 0 THEN
alloc_key := dummy_msg_ptr^.io.allocKey;
END; (* IF alloc_key = 0 THEN *)
dummy_msg_ptr^.location := back_home;
IF dummy_msg_ptr = ADR (left_play_req) THEN
HandlePlayMessage (left_play_req, left_channels, alloc_key);
ELSIF dummy_msg_ptr = ADR (right_play_req) THEN
HandlePlayMessage (right_play_req, right_channels, alloc_key);
ELSE (* Hey, was ist das bloß für eine Nachricht??? *)
Err (FALSE, ver_str + ": got unexpected message (???)");
END; (* ELSIF dummy_msg_ptr = ADR (right_play_req) ELSE *)
END; (* IF dummy_msg_ptr # NIL *)
END; (* IF play_sig <= sigs *)
(*
Control-C? Wenn ja, Schleife verlassen, aufräumen, Programm beenden.
*)
IF ctrlc_sig <= sigs THEN
WriteString ("***Break");
WriteLn;
AbortChannel (left_play_req);
AbortChannel (right_play_req);
quit := TRUE;
(*$ IF DEBUG *)
Terminate ();
(*$ ENDIF *)
END; (* IF ctrlc_sig <= sigs *)
UNTIL (left_play_req.status = quitting) AND (right_play_req.status = quitting);
runtime_error := FALSE;
CLOSE; (* -------------------------------------------------------------- *)
IF NOT runtime_error THEN
IF audio_open THEN
CloseDevice (ADR (left_play_req.io));
audio_open := FALSE;
END; (* IF audio_open *)
IF play_port_ptr # NIL THEN
DeleteMsgPort (play_port_ptr);
play_port_ptr := NIL;
END; (* IF play_port_ptr # NIL *)
IF data_ptr # NIL THEN
FreeMem (data_ptr, rustle_buffer_size);
data_ptr := NIL;
END; (* IF data_ptr # NIL *)
END; (* IF NOT runtime_error THEN *)
IF rdargs_ptr # NIL THEN
FreeArgs (rdargs_ptr);
rdargs_ptr := NIL;
END; (* IF rdargs_ptr # NIL THEN *)
END Rustle.